home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / FILTER.4TH < prev    next >
Text File  |  1994-10-30  |  5KB  |  150 lines
  1.  
  2. \ FILTER INTERFACE
  3. 0 [IF]
  4. COPYRIGHT 1985 (C) BY THOMAS ALMY.  ALL RIGHTS RESERVED
  5. Revision copyright 1991 (C) by Thomas Almy.
  6.  
  7. Permission is granted to registered users of ForthCMP to sell or distribute
  8. computer programs incorporating the compiled contents of this file.
  9.  
  10. DOS2 must be INCLUDED from the main program
  11.  
  12. User functions are SETFILES, BYE, ABORT, CONSOLE, FILTER,
  13.   KEY, EMIT, ACCEPT, SETBUFS and the variable OPTIONSTRING.
  14.   DO NOT use PRINTER and/or MESSAGES (latter is "CONSOLE" here)
  15. SDEFSTR, DDEFSTR, and BUFSIZ tailor the program for
  16.   specific applications.
  17. See UNLOAD.4TH and LIST.4TH for examples of use.
  18. [THEN]
  19.  
  20. \ FILTER SUPORT -- EMITS
  21. 10 DECIMAL    .( LOADING FILTER ) CR
  22. FIND BUFSIZ [IF] DROP [ELSE] 512 CONSTANT BUFSIZ [THEN]
  23. FIND stdin [IF] DROP [ELSE] INCLUDE DOS1 [THEN]
  24. FIND TIB [IF] DROP [ELSE] DSEG CREATE TIB 128 ALLOT [THEN]
  25. FIND >IN [IF] DROP [ELSE] VARIABLE >IN [THEN]
  26. FIND #TIB [IF] DROP [ELSE] VARIABLE #TIB [THEN]
  27. HCB outfile     ( when file is set )
  28. DSEG stdout outfile !  ( set to default to STD-OUTPUT )
  29. VARIABLE outhandle ( handle to use on output )
  30. DSEG stderr outhandle !  ( initially the display )
  31. VARIABLE outbuffer  ( pointer to allocated buffer )
  32. VARIABLE outbufptr
  33. 0 0 IN/OUT 
  34. : flushout   outbuffer @ outbufptr @ <> IF
  35.  outhandle @ outbuffer @ outbufptr @ outbuffer @ - DUP >R write
  36.  outbuffer @ outbufptr ! R> <> IF  stderr outhandle !
  37.    ." DISK FULL " flushout 4 RETURN THEN THEN ;
  38.  
  39. : EMIT  outbufptr @ DUP outbuffer @ BUFSIZ + = IF flushout
  40.    DROP outbuffer @ THEN C! 1 outbufptr +! ;
  41. 0 0 IN/OUT : CONSOLE flushout stderr outhandle ! ;
  42. 0 0 IN/OUT : FILTER  flushout outfile HCB>H outhandle ! ;
  43.  
  44. 1 0 IN/OUT : bye2 ( errorCode -- )
  45.   flushout  stdout outfile @ <> IF ( file to close )
  46.      outfile FCLOSE DROP THEN  RETURN ;
  47. 0 0 IN/OUT : BYE  0 bye2 ;
  48. 0 0 IN/OUT : ABORT 4 bye2 ;
  49.  
  50.  
  51. \ LOW LEVEL INTERFACE -- INPUT
  52. VARIABLE inbuffer  ( pointer to allocated buffer )
  53. VARIABLE inbufptr  VARIABLE inbufend
  54. HCB infile
  55. stdin infile !    \ default
  56.  
  57. 0 0 IN/OUT
  58. : SETBUFS  ( must execute before any I/O to allocate buffers )
  59.   HERE inbuffer !
  60.   BUFSIZ ALLOT
  61.   HERE DUP outbuffer ! outbufptr !
  62.   BUFSIZ ALLOT ;
  63.  
  64.  
  65. \ LOW LEVEL INTERFACE -- KEY AND ACCEPT
  66. \ This version of KEY returns -1 on end of file!
  67. : KEY  inbufptr @ inbufend @ = IF ( fetch block )
  68.     infile @ inbuffer @ BUFSIZ read ?DUP 0= IF ( EOF/ERROR ) -1  EXIT THEN
  69.     inbuffer @ + inbufend !  inbuffer @ inbufptr ! THEN
  70.   inbufptr @ C@  1 inbufptr +!  ;
  71. \ This version of EXPECT returns -1 if end of file!
  72. : ACCEPT ( buffer count -- len )  TUCK 
  73.     0 DO   BEGIN KEY DUP [CTRL] M = WHILE DROP REPEAT
  74.          DUP 0< IF 2DROP TRUE SWAP LEAVE THEN
  75.          DUP [CTRL] Z = IF 2DROP  TRUE SWAP LEAVE THEN
  76.          DUP [CTRL] J = IF 2DROP I SWAP LEAVE THEN
  77.          OVER C! 1+ LOOP DROP ;
  78.  
  79. \ STRING COMPARISON UTILITY WORD
  80. PRIMITIVE
  81. : S= ( string1 string2 length -- flag, true if equal )
  82.   >R  -1 -ROT  R> 0 ?DO
  83.       OVER I + C@  OVER I + C@
  84.            <> IF  ROT DROP 0 -ROT LEAVE THEN
  85.       LOOP
  86.   2DROP ;
  87.  
  88.  
  89. \ SHOULD BACKUP FILE IF SAME
  90. 0 1 IN/OUT : ?samefile  ( -- failflag )
  91.     infile HCB>N outfile HCB>N DUP C@ 1+ S= IF
  92.         ( files are same -- indicate error and abort )
  93.         ." SOURCE AND DESTINATION FILES IDENTICAL "
  94.         -1 ELSE 0 THEN  ;
  95.  
  96. \ SETUP OPTIONS
  97. SEPDSEG? CONSTANT ?dseg
  98. 0 0 IN/OUT : setcommand ( set up for command parsing )
  99.   ?dseg [IF] ?CS: 129 ?DS: TIB 127 CMOVEL [ELSE]
  100.             129 TIB 127 CMOVE [THEN]
  101.   128 CS: C@ #TIB !  >IN OFF ( read args from TIB ) ;
  102. 2VARIABLE OPTIONSTRING
  103. 0 0 IN/OUT : setoptions  ( get option string, if any )
  104.   BL WORD C@ 1 > IF HERE 1+ C@ [CHAR] - = IF ( got one! )
  105.      >IN @ HERE C@ - TIB +  DUP 1- C@ [CHAR] - <> IF 1+ THEN
  106.      HERE C@ 1- OPTIONSTRING 2!   BL WORD DROP EXIT  THEN THEN
  107.      0. OPTIONSTRING 2! ; 
  108. 0 [IF]
  109. A pointer to the options string, and its length, is in the
  110. 2VARIABLE "OPTIONSTRING".  The value is valid until the next
  111. query.
  112. [THEN]
  113.  
  114. \ SET IN DEFAULT EXTENSIONS
  115. FIND SDEFSTR [IF] DROP [ELSE]  0 CONSTANT SDEFSTR  [THEN]
  116. FIND DDEFSTR [IF] DROP [ELSE]  0 CONSTANT DDEFSTR  [THEN]
  117. SDEFSTR DDEFSTR OR [IF]
  118. 2 0 IN/OUT
  119. : setext  ( hcb extension -- )
  120.   SWAP HCB>N DUP >R  1+  ( ext string )
  121.   BEGIN COUNT DUP [CHAR] . = IF DROP BEGIN COUNT DUP 0=
  122.         IF R> 2DROP 2DROP EXIT THEN  [CHAR] \ = UNTIL  1 THEN
  123.         0= UNTIL
  124.   DUP 1- [CHAR] . C<-  ( replace null with dot )
  125.   SWAP COUNT 0 ?DO COUNT 2 PICK C! SWAP 1+ SWAP LOOP
  126.   DROP ( extension address )
  127.   DUP 0 C<-  ( delimit string )
  128.   R@ - 1- R> C!   ( set length byte )
  129.   ;  [THEN]
  130.  
  131. \ MAJOR OPEN DRIVE FUNCTION
  132. 0 1 IN/OUT : SETFILES ( -- failureflag )
  133.   setcommand setoptions
  134.   HERE C@ 0= IF  0 FILTER EXIT THEN
  135.   HERE @ [CHAR] - 8 LSHIFT 1 + <> IF ( input file )
  136.         -1 infile !
  137.           HERE infile NAME>HCB
  138.           SDEFSTR [IF] infile SDEFSTR setext [THEN]
  139.           infile O_RD FOPEN IF infile .FNAME ."  not found" CR
  140.                                    -1 EXIT THEN  THEN
  141.   BL WORD C@ IF HERE @ [CHAR] - 8 LSHIFT 1 + <> IF ( output file )
  142.         -1 outfile !
  143.           HERE outfile NAME>HCB
  144.           DDEFSTR [IF] outfile DDEFSTR setext [THEN]
  145.           ?samefile IF -1 EXIT THEN
  146.           outfile 0 FMAKE IF ." cannot create " outfile CR
  147.                               .FNAME -1 EXIT  THEN
  148.    THEN THEN   0  FILTER ;
  149. HEX 0A = [IF] DECIMAL [THEN]
  150.